Хабрахабр

Стековая машина на моноидах

В ней показывается путь от простой реализации исполнителя байт-кода ко всё более и более эффективным версиям. Не так давно на Хабре появилась отличная и вдохновляющая статья про компиляторы и стековые машины. Мне захотелось показать на примере разработки стековой машины, как это можно сделать 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."

Read. Здесь используется тотальный парсер readMaybe из модуля Text. Можно было бы привести программу и раза в два короче, но уже без информативных сообщениях об ошибках, а это некрасиво.

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

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

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

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

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

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

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

$\texttt \neq \texttt{5 pop dup}.$

Зато нам неважно где программу разрезать, если тут же её в этом месте склеить:

$(\texttt{5 dup}) + \texttt{pop} = \texttt{5} + (\texttt{dup pop}).$

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

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

Может быть, стековые программы образуют группу? "Полугруппа" звучит половинчато, как-то неполноценно. А вот нейтральный элемент у нас есть. Э… нет, большинство программ необратимо, то есть, по результату выполнения не выйдет однозначно восстановить исходные данные. Если в стековом языке такого оператора явно не определили, то его можно легко получить комбинируя некоторые команды, например: $\texttt{inc dec}$, $\texttt{dup pop}$ или $\texttt{swap swap}$. В языках ассемблера он обозначается $\texttt{nop}$ и ничего не делает. Поскольку единица имеется, наши программы образуют полугруппу с единицей или моноид. Такие пары можно безболезненно вырезать из программ или, напротив, вставлять куда угодно в произвольном количестве. Это позволит определить небольшой набор базовых операций для машины, а потом создавать программы с помощью их композиции, получив стековый язык в форме встроенного предметно-ориентированного языка (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

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

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

Примеры программ

-- рекурсивный факториал
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 цепочка начинает превращаться в дерево или в цикл. Данные, в нашем случае, образуются индуктивным образом при склеивании программ оператором $\diamond$, и "хранятся" они в эндоморфизме в виде цепочки композиций функций-преобразователей машины до момента применения этой цепочки к исходному состоянию. Именно эту структуру мы "сворачиваем" при выполнении программы. В общем случае, мы получаем граф, отражающий работу автомата с магазинной памятью, то есть, стековой машины.

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

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

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

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

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

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 = ()

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

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

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)

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

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]

Но можно снова воспользоваться двумя замечательными обстоятельствами: тем что программы образуют моноид и тем что моноиды образуют полугруппу! Обратный гомоморфизм программа $\rightarrow$код построить таким же образом не выйдет, поскольку мы не можем перебирать в 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

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

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

$\mathrm{arity}(\texttt{add}) = 2 \triangleright 1$

Приведём валентности некоторых других операторов:

$\mathrm{arity}(\texttt{push}) = 0 \triangleright 1\\ \mathrm{arity}(\texttt{pop}) = 1 \triangleright 0\\ \mathrm{arity}(\texttt{exch}) = 2 \triangleright 3$

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

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

$(i_1 \triangleright o_1) \diamond (i_2 \triangleright o_2) = (a+i_1) \triangleright (a + o_1 + o_2 - i_2),\qquad a = \max(0, i_2 - o_1).$

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

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

Оптимизация сократила число шагов нужных программе со 107 до 6.

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

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

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

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

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

Посчитаем пример из начала статьи: $(2 \pm 3)*((4 \pm 8)\pm 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 позволяют мастерить то, что даже не могло прийти в голову их создателям, в то время как многие конструкторы не допускают расширения модели — как на фабрике сделали, какую программу зашили, так и будет. Но если серьёзно, то суть и ценность функционального программирования состоит именно в богатстве и гибкости комбинирования. С точки зрения защиты от дурака — это замечательно! Десятками лет люди не перестают находить новые комбинации (это и продолжения и пресловутые монады и линзы-профункторы) с полезными, а иногда и восхитительными свойствами. Функции при комбинировании могут образовывать новые функции, которые снова можно по-разному комбинировать. В любой парадигме можно создавать жёсткие "одноразовые" блоки, громоздя из них фреймворки, требующие производство новых и новых блоков, поскольку они не комбинируются произвольным образом, либо создавать изящные расширяемые долгоживущие решения. Но самое главное — этот подход не прерогатива функционального программирования! Но именно в функциональной парадигме такие решения можно строить последовательно, доказывать и исследовать их свойства математически, оттачивать их прежде чем упаковывать в красивые и непрозрачные коробки и выпускать в мир технологий.

Теги
Показать больше

Похожие статьи

Добавить комментарий

Ваш e-mail не будет опубликован. Обязательные поля помечены *

Кнопка «Наверх»
Закрыть