Не так давно на Хабре появилась отличная и вдохновляющая статья про компиляторы и стековые машины. В ней показывается путь от простой реализации исполнителя байт-кода ко всё более и более эффективным версиям. Мне захотелось показать на примере разработки стековой машины, как это можно сделать Haskell-way.

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

Статья рассчитана на тех, кто владеет языком Haskell на среднем уровне и выше, на тех, кто его уже использует в работе или исследованиях и на всех любопытных, заглянувших поглядеть чего это функциональщики ещё понаворотили. Ну, и для тех, конечно, кого не испугал предыдущий абзац.

Материала получилось много, со множеством примеров в коде, и чтобы облегчить читателю понимание нужно ли ему в неё погружаться, приведу аннотированное содержание.

Задачи трансляции и интерпретации дарят множество интересных и полезных примеров для демонстрации самых разных аспектов программирования. Они позволяют переходить на разные ступени сложности и абстракции, оставаясь при этом вполне практичными. В этой статье мы сосредоточимся на демонстрации возможностей двух важных математических структур — полугруппы и моноида. Они не так часто обсуждаются, как монады или линзы, и ими не пугают маленьких программистов, эти структуры существенно проще для понимания, но при всём том, они лежат в основе функционального программирования. Виртуозное владение моноидальными типами, которое демонстрируют профессионалы, вызывает восхищение простотой и изяществом решений.

Поиск слова "моноид" по статьям на Хабре выдаёт не более четырёх десятков статей (про те же монады, например, их три сотни). Все они концептуально начинают с чего-то вроде: моноид это такое множество... а потом, с вполне понятным восторгом, перечисляют что является моноидом — от строк до пальчиковых деревьев, от парсеров регулярных выражений до бог знает ещё чего! Но на практике мы мыслим в обратном порядке: у нас есть объект, который необходимо моделировать, мы анализируем его свойства и обнаружив, что он обладает признаками той или иной абстрактной структуры, решаем: нужны ли нам следствия из этого обстоятельства и как нам это использовать. Мы пройдём именно этим путём. А заодно добавим в коллекцию полезных моноидов ещё парочку интересных примеров.

Языки и программы для стековых машин

Стековые машины при изучении функционального программирования, обычно появляются в тот момент, когда подходят к концепции свёртки. При этом приводится крайне лаконичная реализация исполнителя простейшего стекового калькулятора, например, такая:

calc :: String -> [Int]
calc = interpretor . lexer
  where
    lexer = words
    interpretor = foldl (flip interprete) []
    interprete c = case c of
      "add" -> binary $ \(x:y:s) -> x + y:s
      "mul" -> binary $ \(x:y:s) -> x * y:s
      "sub" -> binary $ \(x:y:s) -> y - x:s
      "div" -> binary $ \(x:y:s) -> y `div` x:s
      "pop" -> unary  $ \(x:s) -> s
      "dup" -> unary  $ \(x:s) -> x:x:s
      x -> case readMaybe x of
        Just n -> \s -> n:s
        Nothing -> error $ "Error: unknown command " ++ c
      where
        unary f s = case s of
          x:_ -> f s
          _ -> error $ "Error: " ++ c ++ " expected an argument."
        binary f s = case s of
          x:y:_ -> f s
          _ -> error $ "Error: " ++ c ++ " expected two arguments."

Прекрасное начало для разговора! Далее, как правило, начинают навешивать эффекты: меняют свёртку foldl на foldM, обеспечивают тотальность через монаду Either String, потом добавляют логирование, оборачивая всё трасформером WriterT, внедряют с помощью StateT словарь для переменных, и так далее. Иногда, для демонстрации крутости монадических вычислений, реализуют неоднозначный калькулятор, возвращающий все возможные значения выражения $$. Это долгий, хороший и интересный разговор. Однако, свой рассказ мы сразу поведём по-другому, хотя и закончим его тем же результатом.

Почему, вообще, речь заходит о свёртке? Потому что свёртка (катаморфизм) — это абстракция последовательной обработки индуктивных данных. Стековая машина линейно проходит по коду, выполняя последовательность инструкций и порождает одно значение — состояние стека. Мне нравится представлять себе работу свёрточной стековой машины, как трансляцию матричной РНК в живой клетке. Рибосома шаг за шагом проходит всю цепочку РНК, сопоставляет триплеты нуклеотидов с аминокислотами и создаёт первичную структуру белка.

У свёрточной машины есть ряд ограничений, основное — программа всегда прочитывается от начала до конца и один раз. Ветвление, циклы и вызовы подпрограмм требуют концептуального изменения интерпретатора. Ничего сложного, конечно, но такая машина уже не может быть описана простой свёрткой.

Согласно гипотезе лингвистической относительности, свойства используемого нами языка напрямую влияют на свойства нашего мышления. Давайте обратим внимание не на машину, а на языки и программы, которыми она управляется.

Все стеково-ориентированные языки, как относительно низкоуровневые (байт-коды виртуальных машин Java и Python или .NET), так и языки уровнем повыше (PostScript, Forth или Joy), имеют одно фундаментальное общее свойство: если записать последовательно две корректные программы, то получится корректная программа. Правда, корректная не значит "правильная", эта программа может вылетать с ошибкой на любых данных или проваливаться в бесконечные циклы и вообще не иметь смысла, но главное — такая программа сможет быть выполнена машиной. В то же время, разбивая корректную программу на части мы легко можем эти части использовать повторно, именно в силу их корректности. Наконец, в любом стековом языке можно выделить подмножество команд, оперирующих только внутренним состоянием машины (стеком или регистрами), не использующих какую-либо внешнюю память. Это подмножество будет образовывать язык, обладающий свойством конкатенативности. В таком языке любая программа имеет смысл преобразователя состояния машины, а последовательное выполнение программ эквивалентно их композиции, а значит, тоже является преобразователем состояния.

Просматривается общий паттерн: комбинация (конкатенация) корректных программ порождает корректную программу, комбинация преобразователей порождает преобразователь. Получается, что программы стековых языков замкнуты относительно операции конкатенации или образуют структуру, которая называется группоидом или магмой. Это означает, что можно, записав программу на ленту, разрезать её почти как попало и потом из полученных отрезков формировать новые программы. Причём разрезать можно вплоть до отрезков с единственной инструкцией.

При склеивании важен порядок. Например, эти две программы, несомненно, разные:

И что это нам даёт, как программистам? Ассоциативность позволяет выполнять прекомпиляцию, оптимизацию и даже распараллеливание произвольных пригодных для этого отрезков программы, а потом объединять их в эквивалентную программу. Мы можем позволить себе провести статический анализ любого отрезка программы и использовать его в анализе всей программы именно потому, что нам всё равно, где ставить скобки. Это очень важные и серьёзные возможности для языка низкого уровня или промежуточного языка, на котором пишет не человек, а транслятор. А с точки зрения математика и матёрого функциональщика, это делает программы-преобразователи состояния машины полноценными эндоморфизмами. Эндоморфизмы тоже образуют полугруппу с операцией композиции. В алгебре такие эндоморфизмы называются полугруппами трансформации по отношению к какому-либо множеству. Например, конечные автоматы образуют полугруппу трансформации множества состояний.

"Полугруппа" звучит половинчато, как-то неполноценно. Может быть, стековые программы образуют группу? Э… нет, большинство программ необратимо, то есть, по результату выполнения не выйдет однозначно восстановить исходные данные. А вот нейтральный элемент у нас есть. В языках ассемблера он обозначается $$ и ничего не делает. Если в стековом языке такого оператора явно не определили, то его можно легко получить комбинируя некоторые команды, например: $$, $$ или $$. Такие пары можно безболезненно вырезать из программ или, напротив, вставлять куда угодно в произвольном количестве. Поскольку единица имеется, наши программы образуют полугруппу с единицей или моноид. Значит, можно программно реализовать их в виде моноидов — эндоморфизмов над состоянием стековой машины. Это позволит определить небольшой набор базовых операций для машины, а потом создавать программы с помощью их композиции, получив стековый язык в форме встроенного предметно-ориентированного языка (EDSL).

В языке Haskell полугруппы и моноиды описаны с помощью классов Semigroup и Monoid. Их определения просты и отражают только базовую структуру, требования ассоциативности и нейтральности приходится проверять программисту:

class Semigroup a where
  (<>) :: a -> a -> a

class Semigroup a => Monoid a where
  mempty :: a

Строим машину

{-# LANGUAGE LambdaCase, GeneralizedNewtypeDeriving #-}

import Data.Semigroup (Max(..),stimes)
import Data.Monoid
import Data.Vector ((//),(!),Vector)
import qualified Data.Vector as V (replicate)

Мы сразу построим машину, которая располагает стеком, конечной памятью и умеет аварийно останавливаться по-хорошему, чистым образом. Всё это реализуем без использования монад, инкапсулировав необходимые данные в тип, описывающий машину. Таким образом, все базовые программы, а значит и все их комбинации будут чистыми преобразователями её состояния.

Начнём с определения типа для виртуальной машины и тривиальных функций-сеттеров.

type Stack = [Int]
type Memory = Vector Int
type Processor = VM -> VM

memSize = 4

data VM = VM { stack :: Stack
             , status :: Maybe String
             , memory :: Memory }
          deriving Show

emptyVM = VM mempty mempty (V.replicate memSize 0)

setStack :: Stack -> Processor
setStack  x (VM _ s m) = VM x s m

setStatus :: Maybe String -> Processor
setStatus x (VM s _ m) = VM s x m

setMemory :: Memory -> Processor
setMemory x (VM s st _) = VM s st x

Сеттеры нужны для того, чтобы сделать явной семантику программы. Под процессором (тип Processor) мы будем понимать преобразователь VM -> VM.

Теперь определим типы-обёртки для моноида трансформации и для программы:

instance Semigroup (Action a) where
  Action f <> Action g = Action (g . f)

instance Monoid (Action a) where
  mempty = Action id

newtype Program = Program { getProgram :: Action VM }
  deriving (Semigroup, Monoid)

Типы-обёртки определяют принцип комбинирования программ: это эндоморфизмы с обратным порядком композиции (слева направо). Использование обёрток позволяет компилятору самостоятельно определить каким образом тип Program реализует требования классов Semigroup и Monoid.

Исполнитель программ тривиален:

run :: Program -> Processor
run = runAction . getProgram

exec :: Program -> VM
exec prog = run prog emptyVM

Сообщение об ошибке будет формировать функция err:

err :: String -> Processor
err = setStatus . Just $ "Error! " ++ m

Мы используем тип Maybe не так как он используется обычно: пустое значение Nothing в статусе означает, что ничего опасного не происходит, и вычисления можно продолжать, в свою очередь, строковое значение знаменует проблемы. Для удобства, определим два умных конструктора: один — для программ, работающих только со стеком, другой — для тех, которым нужна память.

program :: (Stack -> Processor) -> Program
program f = Program . Action $
  \vm -> case status vm of
    Nothing -> f (stack vm) vm
    _ -> vm

programM :: ((Memory, Stack) -> Processor) -> Program
programM f = Program . Action $
  \vm -> case status vm of
    Nothing -> f (memory vm, stack vm) vm
    _ -> vm

Теперь можно определять базовые команды языка для работы со стеком и памятью, целочисленную арифметику, а также отношения эквивалентности и порядка.

pop = program $ 
  \case x:s -> setStack s
        _ -> err "pop expected an argument."

push x = program $ \s -> setStack (x:s)

dup = program $ 
  \case x:s -> setStack (x:x:s)
        _ -> err "dup expected an argument."

swap = program $ 
  \case x:y:s -> setStack (y:x:s)
        _ -> err "swap expected two arguments."

exch = program $ 
  \case x:y:s -> setStack (y:x:y:s)
        _ -> err "exch expected two arguments."

-- конструктор для функций с ограниченным индексом
indexed i f = programM $ if (i < 0 || i >= memSize)
                         then const $ err $ "expected index in within 0 and " ++ show memSize
                         else f

put i = indexed i $
    \case (m, x:s) -> setStack s . setMemory (m // [(i,x)])
          _ -> err "put expected an argument"

get i = indexed i $ \(m, s) -> setStack ((m ! i) : s)

unary n f = program $
  \case x:s -> setStack (f x:s)
        _ -> err $ "operation " ++ show n ++ " expected an argument"

binary n f = program $
  \case x:y:s -> setStack (f x y:s)
        _ -> err $ "operation " ++ show n ++ " expected two arguments"

add = binary "add" (+)
sub = binary "sub" (flip (-))
mul = binary "mul" (*)
frac = binary "frac" (flip div)
modulo = binary "modulo" (flip mod)
neg = unary "neg" (\x -> -x)
inc = unary "inc" (\x -> x+1)
dec = unary "dec" (\x -> x-1)
eq = binary "eq" (\x -> \y -> if (x == y) then 1 else 0)
neq = binary "neq" (\x -> \y -> if (x /= y) then 1 else 0)
lt = binary "lt" (\x -> \y -> if (x > y) then 1 else 0)
gt = binary "gt" (\x -> \y -> if (x < y) then 1 else 0)

Для полноценной работы не хватает ветвления и циклов. Вообще-то, для встроенного языка достаточно только ветвления, циклы можно организовать с помощью рекурсии во вмещающем языке (в Haskell), но мы сделаем наш язык самодостаточным. Кроме того, воспользуемся тем, что программы образуют полугруппу и определим комбинатор повторения программы указанное число раз. Количество повторений он будет брать со стека.

branch :: Program -> Program -> Program
branch br1 br2 = program go
   where go (x:s) = proceed (if (x /= 0) then br1 else br2) s
         go _ = err "branch expected an argument."

while :: Program -> Program -> Program
while test body = program (const go) 
  where go vm = let res = proceed test (stack vm) vm
          in case (stack res) of
               0:s -> proceed mempty s res
               _:s -> go $ proceed body s res
               _ -> err "while expected an argument." vm

rep :: Program -> Program
rep body = program go
  where go (n:s) = proceed (stimes n body) s
        go _ = err "rep expected an argument."

proceed :: Program -> Stack -> Processor
proceed prog s = run prog . setStack s

Типы функций branch и while говорят о том, что это не самостоятельные программы, а комбинаторы программ: типичный подход при создании EDSL в Haskell. Функция stimes определена для всех полугрупп, она возвращает композицию указанного числа элементов.

Наконец, напишем несколько программ, для опытов.

-- рекурсивный факториал
fact = dup <> push 2 <> lt <>
       branch (push 1) (dup <> dec <> fact) <>
       mul

-- итеративный факториал
fact1 = push 1 <> swap <>
        while (dup <> push 1 <> gt) 
        (
         swap <> exch <> mul <> swap <> dec
        ) <> 
        pop

-- заполняет стек последовательностью чисел
-- в указанном диапазоне
range = exch <> sub <> rep (dup <> inc)

-- ещё один итеративный факториал,
-- записанный через свёртку списка команд
fact2 = mconcat [ dec, push 2, swap, range, push 3, sub, rep mul]

-- итеративный факториал с использованием памяти
fact3 = dup <> put 0 <> dup <> dec <>
        rep (dec <> dup <> get 0 <> mul <> put 0) <>
        get 0 <> swap <> pop

-- копирует два верхних элемента стека
copy2 = exch <> exch

-- вычисляет наибольший общий делитель 
-- по простейшему алгоритму Евклида
gcd1 = while (copy2 <> neq) 
       (
         copy2 <> lt <> branch mempty (swap) <> exch <> sub
       ) <>
       pop

-- возведение в степень методом русского крестьянина
pow = swap <> put 0 <> push 1 <> put 1 <>
      while (dup <> push 0 <> gt)
      (
        dup <> push 2 <> modulo <>
        branch (dec <> get 0 <> dup <> get 1 <> mul <> put 1) (get 0) <>
        dup <> mul <> put 0 <>
        push 2 <> frac
      ) <>
      pop <> get 1

Получилось 120 строк кода с комментариями и аннотациями типов, которые определяют машину, оперирующую 18 командами с тремя комбинаторами. Вот как наша машина работает .

?> exec (push 6 <> fact)
VM {stack = [720], status = Nothing, memory = [0,0,0,0]}

?> exec (push 6 <> fact3)
VM {stack = [720], status = Nothing, memory = [720,0,0,0]}

?> exec (push 2 <> push 6 <> range)
VM {stack = [6,5,4,3,2], status = Nothing, memory = [0,0,0,0]}

?> exec (push 6 <> push 9 <> gcd1)
VM {stack = [3], status = Nothing, memory = [0,0,0,0]}

?> exec (push 3 <> push 15 <> pow)
VM {stack = [14348907], status = Nothing,  memory = [43046721,14348907,0,0]}

?> exec (push 9 <> add)
VM {stack = [9], status = Just "Error! add expected two arguments", memory = [0,0,0,0]}

На самом деле, мы ничего нового не сделали — комбинируя преобразователи-эндоморфизмы, мы, по существу, вернулись к свёртке, но она стала неявной. Напомним, свёртка даёт абстракцию последовательной обработки индуктивных данных. Данные, в нашем случае, образуются индуктивным образом при склеивании программ оператором $$, и "хранятся" они в эндоморфизме в виде цепочки композиций функций-преобразователей машины до момента применения этой цепочки к исходному состоянию. В случае применения комбинаторов branch и while цепочка начинает превращаться в дерево или в цикл. В общем случае, мы получаем граф, отражающий работу автомата с магазинной памятью, то есть, стековой машины. Именно эту структуру мы "сворачиваем" при выполнении программы.

Насколько эффективна такая реализация? Композиция функций — это самое лучшее, что умеет делать компилятор языка Haskell. Он, буквально, рождён для этого! Когда речь заходит о преимуществах использования знания о моноидах, часто приводят пример разностных списков diffList — реализации связного списка в виде композиции эндоморфизмов. Разностные списки принципиально ускоряют формирование списков из множества кусочков благодаря ассоциативности композиции функций. Возня с типами-обёртками не приводит к увеличению накладных расходов, они "растворяются" на этапе компиляции. Из лишней работы остаётся только проверка состояния на каждом шаге выполнения программы.

Комбинируем моноиды

Думаю, к этому моменту скептики и случайные читатели уже нас покинули, можно позволить себе расслабиться и перейти на следующий уровень абстракции.

Концепция полугрупп и моноидов не была бы столь полезной и универсальной, если бы не ряд свойств, присущих всем полугруппам и моноидам без исключения, которые позволяют из простых структур строить сложные точно таким же образом, каким мы строим сложные программы из простых. Эти свойства относятся уже не к объектам, а к типам и их лучше записать не в математической нотации, а в виде программ на Haskell, которые в силу изоморфизма Карри-Ховарда, являются их доказательствами.

1) Моноиды и полугруппы можно "перемножать". Здесь имеется в виду произведение типов, абстракцией которого в Haskell является кортеж или пара.

instance (Semigroup a, Semigroup b) => Semigroup (a,b) where
    (a1, b1) <> (a2, b2) = (a1 <> a2, b1 <> b2)
instance (Monoid a, Monoid b) => Monoid (a,b) where
    mempty = (mempty, mempty )

2) Существует единичный моноид, он представлен единичным типом ():

instance Semigroup () where
    () <> () = ()
instance Monoid () where
    mempty = ()

С операцией перемножения полугруппы сами образуют полугруппу, а принимая во внимание единичный тип, можно сказать, что моноиды образуют моноид! Ассоциативность и нейтральность единицы при этом выполняется с точностью до изоморфизма, но это не принципиально.

3) Отображения в полугруппу или моноид образуют, соответственно, полугруппу или моноид. И тут тоже проще записать это утверждение на Haskell:

instance Semigroup a => Semigroup (r -> a) where
  f <> g = \r -> f r <> g r
instance Monoid a => Monoid (r -> a) where
  mempty = const mempty

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

(command1 <> command2) r   ==  command1 r <> command2 r

Информация может быть любой, например, внешний словарь с какими-то определениями, или способ вести журнал вычислений, нужный при отладке. Это очень похоже на действие монады Reader, которая, как раз, и является просто функцией.

Мы введём в структуру машины журнал, но не будем привязывать его к какому-то определённому типу, а выведем его в параметр типа. Писать в журнал будем с помощью обобщённой моноидальной операции.

data VM a = VM { stack :: Stack
               , status :: Maybe String
               , memory :: Memory
               , journal :: a }
            deriving Show

mkVM = VM mempty mempty (V.replicate memSize 0)

setStack  x (VM _ st m l) = VM x st m l
setStatus st (VM s _ m l) = VM s st m l
setMemory m (VM s st _ l) = VM s st m l
addRecord x (VM s st m j) = VM s st m (x<>j)

newtype Program a = Program { getProgram :: Action (VM a) }
  deriving (Semigroup, Monoid)

type Program' a = (VM a -> VM a) -> Program a

С этого момента мы позволим себе не указывать аннотации типов для всех определений, предоставляя компилятору разбираться с ними самостоятельно, они не сложные, хоть и становятся громоздкими. Сами команды менять не придётся, благодаря умным конструкторам, которые примут на себя все изменения. Совсем небольшие.

program f p = Program . Action $
  \vm -> case status vm of
    Nothing -> p . (f (stack vm)) $ vm
    m -> vm

programM f p = Program . Action $
  \vm -> case status vm of
    Nothing -> p . (f (memory vm, stack vm)) $ vm
    m -> vm

proceed p prog s = run (prog p) . setStack s

rep body p = program go id
  where go (n:s) = proceed p (stimes n body) s
        go _ = err "rep expected an argument."

branch br1 br2 p = program go id
   where go (x:s) = proceed p (if (x /= 0) then br1 else br2) s
         go _ = err "branch expected an argument."

while test body p = program (const go) id
  where go vm = let res = proceed p test (stack vm) vm
          in case (stack res) of
               0:s -> proceed p mempty s res
               _:s -> go $ proceed p body s res
               _ -> err "while expected an argument." vm

Осталось научить вводить внешнюю информацию в исполнитель программ. Это очень просто сделать, создавая различные исполнители с различной стратегией ведения журнала. Первый исполнитель будет самым простым, молчаливым, не тратящим сил на ведение журнала:

exec prog = run (prog id) (mkVM ())

Тут нам пригодился единичный моноид () — нейтральный элемент в алгебре моноидов. Далее, можно определить функцию для исполнителя, готового записывать в журнал ту или иную информацию о состоянии машины.

execLog p prog = run (prog $ \vm -> addRecord (p vm) vm) (mkVM mempty)

Информация может быть, например, такая:

logStack vm   = [stack vm]
logStackUsed  = Max . length . stack
logSteps      = const (Sum 1)
logMemoryUsed = Max . getSum . count . memory
  where count = foldMap (\x -> if x == 0 then 0 else 1)

Проверяем работу:

?> exec (push 4 <> fact2)
VM {stack = [24], status = Nothing, memory = [0,0,0,0], journal = ()}

?> journal $ execLog logSteps (push 4 <> fact2)
Sum {getSum = 14}

?> mapM_ print $ reverse $ journal $ execLog logStack (push 4 <> fact2)
[4]
[3]
[2,3]
[3,2]
[2,2]
[3,2]
[3,3,2]
[4,3,2]
[4,4,3,2]
[5,4,3,2]
[3,5,4,3,2]
[2,4,3,2]
[12,2]
[24]

Логгеры можно комбинировать, пользуясь тем обстоятельством, что моноиды перемножаются. Введём простой комбинатор для логгеров:

f &&& g = \r -> (f r, g r)

Так можно провести сравнение четырёх реализаций факториала по числу шагов и максимальной длине стека

?> let report p = journal $ execLog (logSteps &&& logStackUsed) p

?> report (push 8 <> fact)
(Sum {getSum = 48},Max {getMax = 10})

?> report (push 8 <> fact1)
(Sum {getSum = 63},Max {getMax = 4})

?> report (push 8 <> fact2)
(Sum {getSum = 26},Max {getMax = 9})

?> report (push 8 <> fact3)
(Sum {getSum = 43},Max {getMax = 3})

Логгеры можно было бы объявить моноидом с операцией &&&, если бы они все возвращали одинаковый тип. Но так как они разные, Haskell это сделать не позволяет. Так что не всё, что комбинируется является работающим моноидом.

Программы и их коды

Полноценная отладка подразумевает информацию о выполняемых командах. Но наши команды — это настоящие функции, у них нет имени вне пространства имён Haskell. И тут мы приходим к красивому рассуждению.

Можно сопоставить каждой базовой команде уникальный код, в то же время, можно сопоставить коду — команду. Оба соответствия однозначные, а значит: множества команд и имён изоморфны. Программы (комбинации команд) образуют моноид, и тексты программ (последовательность кодов) образуют моноид. Мы и начинали разговор с того, что разрезали и склеивали именно тексты программ, записанные на лентах. Значит между программами и их кодами можно построить пару взаимно-обратных гомоморфизмов.

Давайте же построим эти отображения! Определим сначала тип для кодов нашего языка:

data Code = IF [Code] [Code]
          | REP [Code]
          | WHILE [Code] [Code]
          | PUT Int | GET Int
          | PUSH Int | POP | DUP | SWAP | EXCH
          | INC | DEC | NEG
          | ADD | MUL | SUB | DIV
          | EQL | LTH | GTH | NEQ
          deriving (Read, Show)

Теперь построим гомоморфизм код $$ программа:

fromCode :: [Code] -> Program' a
fromCode = hom
  where
    hom = foldMap $ \case
      IF b1 b2 -> branch (hom b1) (hom b2)
      REP p -> rep (hom p)
      WHILE t b -> while (hom t) (hom b)
      PUT i -> put i
      GET i -> get i
      PUSH i -> push i
      POP -> pop
      DUP -> dup
      SWAP -> swap
      EXCH -> exch
      INC -> inc
      DEC -> dec
      ADD -> add
      MUL -> mul
      SUB -> sub
      DIV -> frac
      EQL -> eq
      LTH -> lt
      GTH -> gt
      NEQ -> neq
      NEG -> neg

Здесь мы используем то, что программы являются моноидами. foldMap это эффективная свёртка, рассчитанная на моноиды и использующая ассоциативность моноидальных операций. Гомоморфизм fromCode является транслятором программы, записанной в кодах, он уже позволяет транслировать программы, записанные в виде кодов и даже в виде текcта:

?> stack $ exec (fromCode [PUSH 2, PUSH 5, EXCH, SUB, REP [DUP, INC]])
[5,4,3,2]

?> stack $ exec (fromCode $ read "[PUSH 2, PUSH 5, EXCH, SUB, REP [DUP, INC]]")
[5,4,3,2]

Обратный гомоморфизм программа $$ код построить таким же образом не выйдет, поскольку мы не можем перебирать в case функции. Но можно снова воспользоваться двумя замечательными обстоятельствами: тем что программы образуют моноид и тем что моноиды образуют полугруппу! Перемножим в определении типа Program код программы и соответствующий ему трансформер:

newtype Program a = Program { getProgram :: ([Code], Action (VM a)) }
  deriving (Semigroup, Monoid)

run = runAction . snd . getProgram

Наряду с исполняющей функцией run появляется возможность получить код программы и вот он второй гомоморфизм, обратный fromCode:

toCode :: Program' a -> [Code]
toCode prog = fst . getProgram $ prog id

Теперь остаётся переписать выражения для умных конструкторов так, чтобы каждой базовой программе можно было бы указать её код. Впрочем, конструкторы и определения команд языка изменятся не существенно:

type Program' a = (Code -> VM a -> VM a) -> Program a

program c f p = Program . ([c],) . Action $
  \vm -> case status vm of
    Nothing -> p c . f (stack vm) $ vm
    _ -> vm

programM c f p = Program . ([c],) . Action $
  \vm -> case status vm of
    Nothing -> p c . f (memory vm, stack vm) $ vm
    _ -> vm

Как видно, функция, которую мы передаём для ведения журнала стала бинарной, поскольку она теперь располагает кодом программы. Значит надо немного поменять логгеры, а за одно создать логгер для кода и говорливый логгер-отладчик:

none = const id
exec prog = run (prog none) (mkVM ())

execLog p prog = run (prog $ \c -> \vm -> addRecord (p c vm) vm) (mkVM mempty)

logStack _ vm = [stack vm]
logStackUsed _ = Max . length . stack
logSteps _ = const (Sum 1)

-- новые логгеры
logCode c _ = [c]
logRun com vm = [pad 10 c ++ "| " ++ pad 20 s ++ "| " ++ m]
  where c = show com
        m = unwords $ show <$> toList (memory vm)
        s = unwords $ show <$> stack vm
        pad n x = take n (x ++ repeat ' ')

debug :: Program' [String] -> String
debug = unlines . reverse . journal . execLog logRun

pop = program POP $ 
  \case x:s -> setStack s
        _ -> err "POP expected an argument."

push x = program (PUSH x) $ \s -> setStack (x:s)

dup = program DUP $ 
  \case x:s -> setStack (x:x:s)
        _ -> err "DUP expected an argument."

swap = program SWAP $ 
  \case x:y:s -> setStack (y:x:s)
        _ -> err "SWAP expected two arguments."

exch = program EXCH $ 
  \case x:y:s -> setStack (y:x:y:s)
        _ -> err "EXCH expected two arguments."

app1 c f = program c $
  \case x:s -> setStack (f x:s)
        _ -> err $ "operation " ++ show c ++ " expected an argument"

app2 c f = program c $
  \case x:y:s -> setStack (f x y:s)
        _ -> err $ "operation " ++ show c ++ " expected two arguments"

add = app2 ADD (+)
sub = app2 SUB (flip (-))
mul = app2 MUL (*)
frac = app2 DIV (flip div)
neg = app1 NEG (\x -> -x)
inc = app1 INC (\x -> x+1)
dec = app1 DEC (\x -> x-1)
eq = app2 EQL (\x -> \y -> if (x == y) then 1 else 0)
neq = app2 NEQ (\x -> \y -> if (x /= y) then 1 else 0)
lt = app2 LTH (\x -> \y -> if (x > y) then 1 else 0)
gt = app2 GTH (\x -> \y -> if (x < y) then 1 else 0)

proceed p prog s = run (prog p) . setStack s

rep body p = program (REP (toCode body)) go none
  where go (n:s) = if n >= 0
                   then proceed p (stimes n body) s
                   else err "REP expected positive argument."
        go _ = err "REP expected an argument."

branch br1 br2 p = program (IF (toCode br1) (toCode br2)) go none
   where go (x:s) = proceed p (if (x /= 0) then br1 else br2) s
         go _ = err "IF expected an argument."

while test body p = program (WHILE (toCode test) (toCode body)) (const go) none
  where go vm = let res = proceed p test (stack vm) vm
          in case (stack res) of
               0:s -> proceed p mempty s res
               _:s -> go $ proceed p body s res
               _ -> err "WHILE expected an argument." vm

put i = indexed (PUT i) i $
    \case (m, x:s) -> setStack s . setMemory (m // [(i,x)])
          _ -> err "PUT expected an argument"

get i = indexed (GET i) i $ \(m, s) -> setStack ((m ! i) : s)

indexed c i f = programM c $ if (i < 0 || i >= memSize)
                             then const $ err "index in [0,16]"
                             else f

Всё, изоморфизм между программами и их кодами установлен! Давайте посмотрим, как он работает.

Во-первых, мы можем получить код любой программы:

?>  toCode fact1
[PUSH 1,SWAP,WHILE [DUP,PUSH 1,GTH] [SWAP,EXCH,MUL,SWAP,DEC],POP]

Теперь программы можно создавать с помощью EDSL, записывать их в файл и считывать из него.

Во-вторых, можем убедиться в том, что два гомоморфизма toCode и fromCode являются взаимо-обратными.

?> toCode $ fromCode [PUSH 5, PUSH 6, ADD]
[PUSH 5, PUSH 6, ADD]

?> exec (fromCode $ toCode (push 5 <> push 6 <> add))
VM {stack = [11], status = Nothing, memory = [0,0,0,0], journal = ()}

Правда, наш изоморфизм имеет один существенный недостаток: он не позволяет превратить в конечный код программы, определённые с помощью явной рекурсии. Попробуйте в ghci посмотреть код программы fact, только держите пальцы на готове, чтобы поскорее нажать Ctrl+C. Приходится признать, что гомоморфизм toCode существует, но вычислим частично.

Наконец, давайте запустим полноценный отладчик, причём, он-то как раз хорошо работает и с рекурсивными функциями тоже:

?> putStrLn $ debug (push 3 <> fact)
PUSH 3    | 3                   | 0 0 0 0
DUP       | 3 3                 | 0 0 0 0
PUSH 2    | 2 3 3               | 0 0 0 0
LTH       | 0 3                 | 0 0 0 0
DUP       | 3 3                 | 0 0 0 0
DEC       | 2 3                 | 0 0 0 0
DUP       | 2 2 3               | 0 0 0 0
PUSH 2    | 2 2 2 3             | 0 0 0 0
LTH       | 0 2 3               | 0 0 0 0
DUP       | 2 2 3               | 0 0 0 0
DEC       | 1 2 3               | 0 0 0 0
DUP       | 1 1 2 3             | 0 0 0 0
PUSH 2    | 2 1 1 2 3           | 0 0 0 0
LTH       | 1 1 2 3             | 0 0 0 0
PUSH 1    | 1 1 2 3             | 0 0 0 0
MUL       | 1 2 3               | 0 0 0 0
MUL       | 2 3                 | 0 0 0 0
MUL       | 6                   | 0 0 0 0

Освобождение моноида

Код программы имеет вид дерева и он представляет собой чистую информацию о программе. Мы получили свободную алгебру программ для нашей стековой машины. Более того, и сами программы являются свободными структурами, так как мы построили изоморфизм между кодом программы и исполнителем!

Кроме возможностей сериализации и десериализации, свободные структуры предоставляют свободу интерпретации. Мы построили пока только один способ интерпретации свободной программы — в виде трансформаций состояния стековой машины. Но имея программу в свободной форме можно делать с ней что угодно, например обеспечивать форматированный вывод, проводить оптимизацию или статический анализ.

Обычно, на этом замечательном пассаже статья про свободные структуры обрывается: можно и можно, правда сложно и в одном разделе не рассказать. Но так вышло, что наш язык чрезвычайно прост и чрезвычайно моноидален, а это позволяет делать некоторые вещи очень изящно. Грех этим не воспользоваться и не поделиться!

Вот, например, как просто написать форматированный листинг программы:

listing :: Program' a -> String
listing = unlines . hom 0 . toCode
  where
    hom n = foldMap f
      where
        f = \case
          IF b1 b2 -> ouput "IF" <> indent b1 <> ouput ":" <> indent b2
          REP p -> ouput "REP" <> indent p
          WHILE t b -> ouput "WHILE" <> indent t <> indent b
          c -> ouput $ show c

        ouput x = [stimes n "  " ++ x]
        indent = hom (n+1)

И снова строится гомоморфизм: теперь командам ставятся в соответствие строки с отступом, которые, опять же, образуют моноид.

?> putStrLn . listing $ fact2
INC
PUSH 1
SWAP
EXCH
SUB
DUP
PUSH 0
GTH
IF
  REP
    DUP
    INC
:
  NEG
  REP
    DUP
    DEC
DEC
DEC
REP
  MUL

?> putStrLn . listing $ gcd1
WHILE
  EXCH
  EXCH
  NEQ
  EXCH
  EXCH
  LTH
  IF
  :
    SWAP
  EXCH
  SUB
POP

Не будем на этом останавливаться и попробуем провести нехитрый статический анализ программ для стековой машины. Тип данных у нас один, так что статическая типизация для языка не актуальна, зато на стеке может не хватить данных для выполнения программы. У нас есть возможность вычислить строгие требования для работы программы до её выполнения.

Введём такую характеристику программ, как валентность — это информация о максимальном количестве аргументов, которые должны быть на стеке перед её выполнением и о минимальном числе элементов которые останутся на стеке после её выполнения. Например перед выполнением операции сложения нужно иметь на стеке не менее двух элементов, а после выполнения останется как минимум один элемент. Мы запишем это обстоятельство в таком виде:

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

infix 7 :>
data Arity = Int :> Int 
  deriving (Show,Eq)

instance Semigroup Arity where
  (i1 :> o1) <> (i2 :> o2) = let a = 0 `max` (i2 - o1)
                             in (a + i1) :> (a + o1 + o2 - i2)
instance Monoid Arity where
  mempty = 0:>0

А после чего можно строить гомоморфизм:

arity :: Program' a -> Arity
arity = hom . toCode
  where
    hom = foldMap $
      \case
        IF b1 b2 -> let i1 :> o1 = hom b1
                        i2 :> o2 = hom b2
                    in 1:>0 <> (i1 `max` i2):>(o1 `min` o2)
        REP p -> 1:>0
        WHILE t b -> hom t <> 1:>0
        PUT _ -> 1:>0
        GET _ -> 0:>1
        PUSH _ -> 0:>1
        POP -> 1:>0
        DUP -> 1:>2
        SWAP -> 2:>2
        EXCH -> 2:>3
        INC -> 1:>1
        DEC -> 1:>1
        NEG -> 1:>1
        _   -> 2:>1

Комбинаторы циклов имеют валентность, не зависящую от тела цикла, поскольку код тела при выполнении программы может не исполниться вовсе. А так как мы рассматриваем строгие требования, мы можем точно сказать, что гарантированно выполнится только проверка на вход в цикл.

Рассчитаем требования для некоторых программ (кроме рекурсивных):

?> arity (exch <> exch)
2 :> 4

?> arity fact1
1 :> 1

?> arity range
2 :> 1

?> arity (push 3 <> dup <> pow)
0 :> 1

Что ещё можно посчитать перед выполнением? Так как регистры памяти указываются статически, каждая программа "знает" какой объём памяти ей потребуется. Можно построить гомоморфизм Program' a -> Max Int, и при иниализации машины создавать область памяти нужного объёма. Он может быть построен, например, так:

memoryUse :: Program' a -> Max Int
memoryUse = hom . toCode
  where
    hom = foldMap $
      \case
        IF b1 b2 -> hom b1 <> hom b2
        REP p -> hom p
        WHILE t b -> hom t <> hom b
        PUT i -> Max (i+1)
        GET i -> Max (i+1)
        _ -> 0

?> memoryUse fact1
Max {getMax = 0}

?> memoryUse fact3
Max {getMax = 1}

?> memoryUse pow
Max {getMax = 2}

При конкатенации программ могут возникать конфликты с совместным использованием памяти. Это можно решить автоматически вводя соответствующие смещения для всех указываемых индексов, ведь на требования памяти доступны до выполнения программы.

Вычисление валентности позволяет провести простую, но эффектную оптимизацию: можно выделять максимально длинные непрерывные линейные отрезки программ, которые не требуют элементов на стеке перед выполнением, то есть, с валентностью 0:>_ и не задействуют память. Такие цепочки не зависят от текущих данных и могут быть вычислены заранее и заменены результатом на этапе трансляции. Обычно, это арифметические вычисления.

isReducible p = let p' = fromCode p
                in case arity p' of
                     0:>_ -> memoryUse p' == 0
                     _    -> False

reducible = go [] . toCode
  where go res [] = reverse res
        go res (p:ps) = if isReducible [p]
                        then let (a,b) = spanBy isReducible (p:ps)
                             in go (a:res) b
                        else go res ps

-- здесь используется моноид Last, который комбинируется,
-- оставляя последний нетривиальный результат
spanBy test l = case foldMap tst $ zip (inits l) (tails l) of
                  Last Nothing -> ([],l)
                  Last (Just x) -> x
  where tst x = Last $ if test (fst x) then Just x else Nothing 

-- здесь используется моноид Endo комбинирующийся как эндоморфизм
-- функции intercalate и splitOn можно подгрузить из библиотек
-- Data.List и Data.List.Split
reduce p = fromCode . process (reducible p) . toCode $ p
  where
    process = appEndo . foldMap (\x -> Endo $ x `replaceBy` shrink x)
    shrink = toCode . foldMap push . reverse . stack . exec . fromCode
    replaceBy x y = intercalate y . splitOn x

?> let p = push 6 <> fact1 <> swap <> push 5 <> dup <> push 14 <> gcd1 <> put 1

?> toCode $ p
[PUSH 6,PUSH 1,SWAP,WHILE [DUP,PUSH 1,GTH] 
[SWAP,EXCH,MUL,SWAP,DEC],POP,SWAP,PUSH 5,DUP,PUSH 14,WHILE 
[EXCH,EXCH,NEQ] [EXCH,EXCH,LTH,IF [] [SWAP],EXCH,SUB],POP,PUT 1]

?> toCode $ reduce p
[PUSH 720,SWAP,PUSH 5,PUSH 1,PUT 1]

?> execLog logSteps (push 8 <> p)
VM {stack = [5,8,720], status = Nothing, memory = [0,1,0,0], 
journal = Sum {getSum = 107}}

?> execLog logSteps (push 8 <> reduce p)
VM {stack = [5,8,720], status = Nothing, memory = [0,1,0,0], 
journal = Sum {getSum = 6}}

Далее, от валентности можно перейти, скажем, к тройкам Хоара и формально верифицировать программы, выводя логические пред- и постусловия для работы линейных участков программ (для циклов придётся возиться инвариантами).

От моноидов к монадам и снова к моноидам

Но что если нашей машине нужно выйти в мир эффектов: общаться с пользователем, с файловой системой, базой данных, случайными числами и т.д.? Можно ли наше решение оснастить монадическими вычислениями? Можно, хоть и придётся переписывать реализацию, но оно того стоит!

При использовании монады m преобразователи VM -> VM должны превратиться в VM -> m VM, это уже не эндоморфизм. Но вспомним крылатую фразу: "Монада — это всего лишь моноид в категории эндофункторов, в чём проблема?!" В категории Клейсли, которую образуют преобразователи VM -> m VM определена композиция, а она, согласно правилам категорий, ассоциативна и имеет нейтральный элемент. Эту композицию в Haskell обозначают оператором >=> и называют "рыбкой Клейсли". Значит, для выхода в мир вычислений с эффектами достаточно поменять начинку Action на моноид ActionM, определив его следующим образом:

newtype ActionM m a = ActionM { runActionM :: a -> m a }

instance Monad m => Semigroup (ActionM m a) where
  ActionM f <> ActionM g = ActionM (f >=> g)

instance Monad m => Monoid (ActionM m a) where
  mempty = ActionM return

Поменяются сеттеры, они должны стать монадическими, и везде вместо их композиции надо будет будет использовать оператор >=>. Все же прочие определения останутся без изменений.

{-# LANGUAGE LambdaCase, GeneralizedNewtypeDeriving, TupleSections #-}

import Data.Monoid hiding ((<>))
import Data.Semigroup (Semigroup(..),stimes,Max(..))
import Data.Vector ((//),(!),Vector,toList)
import qualified Data.Vector as V (replicate)
import Control.Monad
import Control.Monad.Identity

type Stack = [Int]
type Memory = Vector Int

memSize = 4

data VM a = VM { stack :: Stack
               , status :: Maybe String
               , memory :: Memory
               , journal :: a }
            deriving Show

mkVM = VM mempty mempty (V.replicate memSize 0)

setStack  x (VM _ st m l) = return $ VM x st m l
setStatus st (VM s _ m l) = return $ VM s st m l
setMemory m (VM s st _ l) = return $ VM s st m l
addRecord x (VM s st m l) = VM s st m (x<>l)

------------------------------------------------------------

data Code = IF [Code] [Code]
          | REP [Code]
          | WHILE [Code] [Code]
          | PUT Int | GET Int
          | PUSH Int | POP | DUP | SWAP | EXCH
          | INC | DEC | NEG
          | ADD | MUL | SUB | DIV | MOD
          | EQL | LTH | GTH | NEQ
          | ASK | PRT | PRTS String
          | FORK [Code] [Code]
          deriving (Read, Show)

newtype ActionM m a = ActionM {runActionM :: a -> m a}

instance Monad m => Semigroup (ActionM m a) where
  ActionM f <> ActionM g = ActionM (f >=> g)

instance Monad m => Monoid (ActionM m a) where
  ActionM f `mappend` ActionM g = ActionM (f >=> g)
  mempty = ActionM return

newtype Program m a = Program { getProgram :: ([Code], ActionM m (VM a)) }
  deriving (Semigroup, Monoid)

type Program' m a = (Code -> VM a -> m (VM a)) -> Program m a

program c f p = Program . ([c],) . ActionM $
  \vm -> case status vm of
    Nothing -> p c =<< f (stack vm) vm
    m -> return vm

programM c f p = Program . ([c],) . ActionM $
  \vm -> case status vm of
    Nothing -> p c =<< f (memory vm, stack vm) vm
    m -> return vm

run :: Monad m => Program m a -> VM a -> m (VM a) 
run = runActionM . snd . getProgram

toCode :: Monad m => Program' m a -> [Code]
toCode prog = fst . getProgram $ prog none

none :: Monad m => Code -> VM a -> m (VM a)
none = const return

-- запуск программы вне монад
exec :: Program' Identity () -> VM ()
exec = runIdentity . execM

execM :: Monad m => Program' m () -> m (VM ())
execM prog = run (prog none) (mkVM ())

execLog p prog = run (prog $ \c -> \vm -> return $ addRecord (p c vm) vm) (mkVM mempty)

f &&& g = \c -> \r -> (f c r, g c r)

logStack _ vm   = [stack vm]
logStackUsed _ = Max . length . stack
logSteps _     = const (Sum 1)
logCode c _   = [c]
logRun com vm = [pad 10 c ++ "| " ++ pad 20 s ++ "| " ++ m]
  where c = show com
        m = unwords $ show <$> toList (memory vm)
        s = unwords $ show <$> stack vm
        pad n x = take n (x ++ repeat ' ')

debug p = unlines . reverse . journal <$> execLog logRun p

------------------------------------------------------------
pop,dup,swap,exch :: Monad m => Program' m a
put,get,push :: Monad m => Int -> Program' m a
add,mul,sub,frac,modulo,inc,dec,neg :: Monad m => Program' m a
eq,neq,lt,gt :: Monad m => Program' m a

err m = setStatus . Just $ "Error : " ++ m

pop = program POP $ 
  \case x:s -> setStack s
        _ -> err "pop expected an argument."

push x = program (PUSH x) $ \s -> setStack (x:s)

dup = program DUP $ 
  \case x:s -> setStack (x:x:s)
        _ -> err "dup expected an argument."

swap = program SWAP $ 
  \case x:y:s -> setStack (y:x:s)
        _ -> err "swap expected two arguments."

exch = program EXCH $ 
  \case x:y:s -> setStack (y:x:y:s)
        _ -> err "expected two arguments."

put i = indexed (PUT i) i $
    \case (m, x:s) -> setStack s <=< setMemory (m // [(i,x)])
          _ -> err "put expected an argument"

get i = indexed (GET i) i $ \(m, s) -> setStack ((m ! i) : s)

indexed c i f = programM c $ if (i < 0 || i >= memSize)
                             then const $ err "index in [0,16]"
                             else f

app1 c f = program c $
  \case x:s -> setStack (f x:s)
        _ -> err $ "operation " ++ show c ++ " expected an argument"

app2 c f = program c $
  \case x:y:s -> setStack (f x y:s)
        _ -> err $ "operation " ++ show c ++ " expected two arguments"

add = app2 ADD (+)
sub = app2 SUB (flip (-))
mul = app2 MUL (*)
frac = app2 DIV (flip div)
modulo = app2 MOD (flip mod)
neg = app1 NEG (\x -> -x)
inc = app1 INC (\x -> x+1)
dec = app1 DEC (\x -> x-1)
eq = app2 EQL (\x -> \y -> if (x == y) then 1 else 0)
neq = app2 NEQ (\x -> \y -> if (x /= y) then 1 else 0)
lt = app2 LTH (\x -> \y -> if (x > y) then 1 else 0)
gt = app2 GTH (\x -> \y -> if (x < y) then 1 else 0)

proceed p prog s = run (prog p) <=< setStack s

rep body p = program (REP (toCode body)) go none
  where go (n:s) = if n >= 0
                   then proceed p (stimes n body) s
                   else err "rep expected positive argument."
        go _ = err "rep expected an argument."

branch br1 br2 p = program (IF (toCode br1) (toCode br2)) go none
   where go (x:s) = proceed p (if (x /= 0) then br1 else br2) s
         go _ = err "branch expected an argument."

while test body p = program (WHILE (toCode test) (toCode body)) (const go) none
  where go vm = do res <- proceed p test (stack vm) vm
                   case (stack res) of
                     0:s -> proceed p mempty s res
                     _:s -> go =<< proceed p body s res
                     _ -> err "while expected an argument." vm

ask :: Program' IO a
ask = program ASK $
  \case s -> \vm -> do x <- getLine
                       setStack (read x:s) vm

prt :: Program' IO a
prt = program PRT $
  \case x:s -> \vm -> print x >> return vm
        _ -> err "PRT expected an argument"

prtS :: String -> Program' IO a
prtS s = program (PRTS s) $
  const $ \vm -> print s >> return vm

fork :: Program' [] a -> Program' [] a -> Program' [] a
fork br1 br2 p = program (FORK (toCode br1) (toCode br2)) (const go) none
  where go = run (br1 p) <> run (br2 p)

------------------------------------------------------------

fromCode :: Monad m => [Code] -> Program' m a
fromCode = hom
  where
    hom = foldMap $ \case
      IF b1 b2 -> branch (hom b1) (hom b2)
      REP p -> rep (hom p)
      WHILE t b -> while (hom t) (hom b)
      PUT i -> put i
      GET i -> get i
      PUSH i -> push i
      POP -> pop
      DUP -> dup
      SWAP -> swap
      EXCH -> exch
      INC -> inc
      DEC -> dec
      ADD -> add
      MUL -> mul
      SUB -> sub
      DIV -> frac
      MOD -> modulo
      EQL -> eq
      LTH -> lt
      GTH -> gt
      NEQ -> neq
      NEG -> neg
      _ -> mempty

fromCodeIO :: [Code] -> Program' IO a
fromCodeIO = hom
  where
    hom = foldMap $ \case
      IF b1 b2 -> branch (hom b1) (hom b2)
      REP p -> rep (hom p)
      WHILE t b -> while (hom t) (hom b)
      ASK -> ask
      PRT -> ask
      PRTS s -> prtS s
      c -> fromCode [c]

fromCodeList :: [Code] -> Program' [] a
fromCodeList = hom
  where
    hom = foldMap $ \case
      IF b1 b2 -> branch (hom b1) (hom b2)
      REP p -> rep (hom p)
      WHILE t b -> while (hom t) (hom b)
      FORK b1 b2 -> fork (hom b1) (hom b2)
      c -> fromCode [c]

В рамках такой модели вычислений можно определить две новых команды: для считывания данных из stdin или с клавиатуры и для вывода значения либо сообщения на печать.

ask, prt :: Program' IO a
ask = program ASK $
  \case s -> \vm -> do x <- getLine
                       setStack (read x:s) vm

prt = program PRT $
  \case x:s -> \vm -> print x >> return vm
        _ -> err "PRT expected an argument"

prtS :: String -> Program' IO a
prtS s = program (PRTS s) $
  const $ \vm -> print s >> return vm

Теперь можно написать что-то такое интерактивное и убедиться в том, что нам удалось совместить вычисления и эффекты:

ioprog = prtS "input first number" <> ask <>
         prtS "input second number" <> ask <>
         rep (prt <> dup <> inc) <>
         prt

?> exec ioprog
 input first number
 3 
 input second number
 5 
 3
 4
 5
 6
 7
 8
 VM {stack = [8,7,6,5,4,3], status = Nothing, memory = [0,0,0,0], journal = ()}

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

fork :: Program' [] a -> Program' [] a -> Program' [] a
fork br1 br2 p = program (FORK (toCode br1) (toCode br2)) (const go) pure
  where go = run (br1 p) <> run (br2 p)

Здесь опять сработала алгебра моноидов: функции run возвращают преобразователь VM -> m VM, их моноидальная композиция — функцию, возвращающую композицию преобразователей, но теперь уже в рамках монады [], то есть — список вариантов.

Результатом работы разветвлённой программы будет список конечный состояний машины:

?> stack <$> exec (push 5 <> push 3 <> add `fork` sub)
[[8],[2]]

?> stack <$> exec (push 5 <> push 3 `fork` dup <> push 2)
[[2,3,5],[2,5,5]]

Посчитаем пример из начала статьи: $$:

?> let pm = add `fork` sub
?> stack <$> exec (push 2 <> push 3 <> push 4 <> push 8 <> pm <> push 5 <> pm <> pm <> mul)
[[40],[-28],[20],[-8],[8],[4],[-12],[24]]

А вот сравнение эффективности четырёх реализаций факториалов:

?> journal <$> execLog logSteps (push 8 <> fact `fork` fact1 `fork` fact2 `fork` fact3)
[Sum {getSum = 48},Sum {getSum = 63},Sum {getSum = 34},Sum {getSum = 43}]

Записать выражение из четырёх ветвей вычислений без скобок нам позволило то, что программы образуют моноид с операцией fork, значит, операция fork ассоциативна.

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

С древне-греческого ????? переводится как грязь или тесто. Действительно, склеивая куски теста, мы вновь будем получать куски теста, которые можно склеивать. Это кажется более чем тривиальным наблюдением, но именно в этом заключается очарование пластилина или, например, конструктора Lego: благодаря универсальному интерфейсу соединение двух кубиков конструктора порождает новый кубик, готовый с кем-нибудь соединиться. С игрушками, соединяемыми липучками, например, так уже не получится.

Кубики Lego позволяют мастерить то, что даже не могло прийти в голову их создателям, в то время как многие конструкторы не допускают расширения модели — как на фабрике сделали, какую программу зашили, так и будет. И как ни соединяй, получится только то, что предусмотрено конструкцией либо неработающий хлам. С точки зрения защиты от дурака — это замечательно! Но если серьёзно, то суть и ценность функционального программирования состоит именно в богатстве и гибкости комбинирования. Функции при комбинировании могут образовывать новые функции, которые снова можно по-разному комбинировать. Десятками лет люди не перестают находить новые комбинации (это и продолжения и пресловутые монады и линзы-профункторы) с полезными, а иногда и восхитительными свойствами. Но самое главное — этот подход не прерогатива функционального программирования! В любой парадигме можно создавать жёсткие "одноразовые" блоки, громоздя из них фреймворки, требующие производства новых и новых блоков, поскольку они не комбинируются произвольным образом, либо создавать изящные расширяемые долгоживущие решения. Но именно в функциональной парадигме такие решения можно строить последовательно, доказывать и исследовать их свойства математически, оттачивать их прежде чем упаковывать в красивые и непрозрачные коробки и выпускать в мир технологий.

Все модули доступны в репозитории. Кое-какие цифры, отражающие производительность решения добавлены в комментарии. Самый важный результат — использование моноида в категории Клейсли открывает возможности для существенного увеличения скорости выполнения программ стековой машины, использующей память. Принцип построения программы при этом не меняется.