Подмешиваем эффекты - теория

Есть у меня один проектик, никому, кроме меня, не нужный, а потому холимый, лелеемый и регулярно вычёсываемый. Проектик большой, целых двести строк (чёрт, исходники картинок к этой статье чуть не в два раза больше, и я уж молчу про саму статью) и под десять килобайт исходников (да, я люблю длинные строки). Временами из него вычленяются отдельные куски, которые вполне можно показать людям. Вот, на днях один такой попался. Родился он из медитации над заброшенным пакетом lax с hackage, который благополучно не устанавливается cabal-ом, но при этом состоит всего из одного вполне рабочего файла, который можно просто взять и использовать (ну, прагму надо будет прописать в начале).
Окончили лирику, переходим к делу. Задачка передо мной стояла совершенно классическая — взять две стрелки, перемешать, посолить, поперчить и сделать из них одну.
Чуть более подробно. У меня была некая стрелка. Вполне себе чистенькая — писалась исключительно с использованием чистых функций. Возникла необходимость добавить к ней эффекты — то есть, пока работают "эффекты" самой стрелки, дополнительно ещё производить некое IO. То есть, наши стрелки изначально неравноправны: есть стрелка a, которая, по сути, будет ни чем иным, как Kleisli IO, и стрелка b, делающая основную работу, но при этом чистая. И мы хотим слепить из всего этого что-то одно.
Основная идея будет такой: мы организуем некий цикл, где то, что подаётся на вход, будет сразу скармливаться стрелке b, часть выхода пойдёт к стрелке a, а то, что она выдаст, будет возвращаться к b:


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


Посмотрим, удастся ли при таком подходе сделать что-нибудь полезное. Для начала, хорошо бы убедиться, что мы можем встроить в это дело исходные стрелки a и b. Оказывается, вполне можем, и вот как:




Комбинатор first делается элементарно:


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



Мы можем перерисовать это дело так, чтобы стало более похоже на один цикл:



И вот тут нас поджидает засада.
Засада состоит в следующем. Забудем пока про чистую стрелку b, она не имеет значения. Допустим, мы поднимаем и соединяем последовательно две стрелки с эффектами, одна из которых читает ввод, а другая его же выводит обратно на экран. Мы получим, фактически, следующее:


Я чуть разверну цикл, чтобы интересные нам стрелки смотрели слева направо:


Что мы видим? А видим мы, что стрелка putStrLn на вход принимает то, что возвращается назад мимо неё. Увы, монада IO к таким штукам относится очень нервно. Если мы аккуратно напишем всё то, о чём пока говорили неформально, и запустим этот пример, то получим классическое "Expression: <<loop>>". А это не та реакция, которая нам нужна.
Желающие в этом убедиться могут попробовать такой пример:

echoL =
    proc ((), line) ->
        do line' <- Kleisli (const getLine) -< ()
           Kleisli putStrLn -< line
           returnA -< ((), line')
echo = runKleisli (loop echoL) ()

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



— а это гораздо лучше. Настолько лучше, что работает.
Есть и другое описание такого решения: везде, где что-то соединяется в пары, можно найти композицию. Это эмпирический (пока, по крайней мере) принцип, но он работает. В данном случае, композиция наших циклов приводит к тому, что "обратные" стрелки в нижней части цикла соединяются параллельно — а значит, композиция где-то рядом.
Более точно. Вместо одной стрелки



мы берём функцию (чистую!), которая вот такую стрелку:



преобразует вот в такую:



Тогда параллельное соединение стрелок, которое мы использовали раньше, превратится как раз-таки в композицию. Изобразить это дело на диаграмме уже не получится, или, по крайней мере, будет весьма затруднительно; поэтому, я нарисую несколько диаграмм так, как будто мы используем старое, "наивное" решение с одной стрелкой a, а уж в коде будет "продвинутое" решение, с функцией, преобразующей стрелки.
Собственно говоря, нарисовать осталось немногое. Займёмся комбинатором loop. То есть, у нас есть вот такая конструкция:



и мы хотим замкнуть нижние "висящие" хвосты. Интересно то, что мы можем это сделать двумя способами. Первый способ — ввести цикл в стрелку b, второй — пустить его вдоль стрелки a. С точки зрения диаграмм получается такое:






Самое смешное в том, что я не нашёл отличий в их функциональности. Может, конечно, они и есть, но мне лично кажется, что они эквивалентны, причём что это можно формально доказать. В ближайшее время я этим попробую заняться. Первый вариант, однако, записывается короче, выглядит более похоже на другие комбинаторы, и, в целом, больше мне нравится. Так что, использовать я буду именно его, а второй вариант пойдёт комментарием.
Наконец, самый важный вопрос: можем ли мы получить из таких циклов что-нибудь обратно? А то, выглядят они, конечно, симпатично, но не более того. Ответ — да, можем, но не вполне банальным образом. Идея в том, чтобы для начала заменить стрелку b на функцию, а затем оставить вообще только стрелку a, от которой нам, так уж получилось, деваться некуда — именно в ней будут настоящие эффекты, которые в чистую функцию не переделать никак. В наивном подходе нам нужно будет замкнуть цикл, воспользовавшись тем, что стрелка a имеет оператор loop; в продвинутом подходе всё окажется на порядок проще.
Продолжение следует.

Подмешиваем эффекты - практика

Продолжение. Начало здесь

> {-# LANGUAGE Arrows, GADTs, GeneralizedNewtypeDeriving, Rank2Types, TupleSections, TypeOperators #-}

Выглядит страшно, но, на самом деле, ничего серьёзного здесь нет. Лишь два расширения из этих шести добавляют настоящие возможности, а остальные четыре дают лишь удобный синтаксический сахар — позволяют использовать стрелочный синтаксис (забегая вперёд, скажу, что он нам понадобится только в примерах), позволяют автоматически выводить типы для newtype-ов, упрощают частичное применение оператора (,) и упрощают запись сложных типов. Синтаксический сахар. Но очень удобный. Но сахар. Но по пять рублей.

> module Mix where
> import Prelude hiding (id, (.))

Очень рекомендую ставить эту строчку всегда, когда используются стрелки. Дело в том, что модуль Control.Category экспортирует свои, более общие в смысле типов определения id и (.). А если есть более общие — зачем нам их конфликты с менее общими?

> import Control.Arrow
> import Control.Category

Для примеров — и только для примеров — мы будем использовать монаду State:

> import Control.Monad.State

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

> swap ~(a, b) = (b, a)
> twist ~((a, b), c) = ((a, c), b)
> assocLtoR ~((a, b), c) = (a, (b, c))
> assocRtoL ~(a, (b, c)) = ((a, b), c)

Заметим, что в модуле Data.Tuple имеется аналогичная функция swap, но она излишне строга — здесь мы используем ленивые паттерны где только можно. Не проверял, важно ли это, но для типов с одним конструктором лучше использовать ленивый паттерн всегда (если только это не newtype, потому что для него ленивый и строгий паттерн-матчинг означает одно и то же).
Ещё несколько функций, которые делают то же самое (перетасовывают элементы) со стрелками:

> arrTwist :: Arrow a => a ((ia, ib), ic) ((oa, ob), oc) -> a ((ia, ic), ib) ((oa, oc), ob)
> arrTwist a = twist ^>> a >>^ twist
> arrAssocLtoR :: Arrow a => a ((ia, ib), ic) ((oa, ob), oc) -> a (ia, (ib, ic)) (oa, (ob, oc))
> arrAssocLtoR a = assocRtoL ^>> a >>^ assocLtoR
> arrAssocRtoL :: Arrow a => a (ia, (ib, ic)) (oa, (ob, oc)) -> a ((ia, ib), ic) ((oa, ob), oc)
> arrAssocRtoL a = assocLtoR ^>> a >>^ assocRtoL
> arrCancelUnit :: Arrow a => a (i, ()) (o, ()) -> a i o
> arrCancelUnit a = (,()) ^>> a >>^ fst

Теперь начинается самое интересное. Мы вводим морфизм стрелок — как я говорил, мы будем одну стрелку переделывать в другую — в стрелку (->), чтобы быть точным.

> type f :~> g = forall i o. f i o -> g i o

Мы будем использовать этот тип не только со стрелками, но и с другими стрелкоподобными структурами, в частности с

> type Along a i o input output = a (input, i) (output, o)

Это оно самое — стрелка с двумя входами и двумя выходами, которая у нас несколько раз встречалась в диаграммах.
И, наконец, наш тип:

> data Mix a b input output where Mix :: (Along a i o :~> a) -> Along b i o input output -> Mix a b input output

В наивном варианте первый аргумент конструктора имел бы просто тип a o i, но мы используем продвинутый вариант.
Поднимаем наши исходные стрелки:

> liftA :: (ArrowLoop a, Arrow b) => a input output -> Mix a b input output
> liftA a = Mix (\al -> loop $ al >>> second a) (arr swap)

Здесь тип i будет совпадать с output, а тип o — с input.
Важно отметить, что заведомо нечистая часть идёт в этом случае после той части, которая может быть чистой. Именно за счёт этого мы избавляемся от неправильных цикловых зависимостей, когда что-то нечистое зависит от того, что реально считается позднее. Желающие могут заменить это определение на такое:

liftA a = Mix (\al -> loop $ second a >>> al) (arr $ swap . first Left)

и попробовать запустить те же примеры (приведённые ниже) в таком варианте. "Expression: <<loop>>", вот что получится в результате.

> liftB :: (Arrow a, Arrow b) => b input output -> Mix a b input output
> liftB b = Mix arrCancelUnit (first b)

Ну, далее нужно делать наши циклы стрелками. Заметим, кстати, что мы сохраняем порядок эффектов в композиции: мы хотим сначала сделать a1, а потом — a2.

> instance (Arrow a, Arrow b) => Category (Mix a b) where
>     id = liftB id
>     Mix a2 b2 . Mix a1 b1 = Mix (a2 . a1 . arrAssocRtoL) (arrAssocLtoR $ twist ^>> first b1 >>> twist ^>> first b2)
> instance (Arrow a, Arrow b) => Arrow (Mix a b) where
>     arr = liftB . arr
>     first (Mix a b) = Mix a (arrTwist $ first b)

Теперь комбинатор loop. Как я и обещал, я приведу два варианта: основной, который использую я:

> instance (Arrow a, ArrowLoop b) => ArrowLoop (Mix a b) where loop (Mix a b) = Mix a (loop $ arrTwist b)

и дополнительный:

instance (ArrowLoop a, Arrow b) => ArrowLoop (Mix a b) where loop (Mix a b) = Mix (loop . a . arrAssocRtoL) (arrAssocLtoR b)

Внимательный читатель уже заметил, что они отличаются контекстом. При наивном подходе дополнительный вариант имел бы контекст (Arrow a, Arrow b), но работал бы хуже — те маленькие примеры, которые работали бы с первым вариантом, не могли бы работать со вторым, но не наоборот. А вот в продвинутом подходе разницы, похоже, нет.
Далее, мы хотим преобразовывать одну стрелку в другую. Казалось бы разумным использовать тип (b :~> c) -> (Mix a b :~> Mix a c) Это возможно, но мы поступим несколько более общим образом. Мне, в моём домашнем проектике, эта общность пригодилась. Кроме того, мы уберём такую функцию в класс — впоследствии пригодится.

> class AlongMap f where
>     alongMap :: (Arrow b, Arrow c) => (Along b input1 output1 :~> Along c input2 output2) -> (Along (f b) input1 output1 :~> Along (f c) input2 output2)
> instance AlongMap (Mix a) where alongMap h (Mix a b) = Mix a (arrTwist $ h $ arrTwist b)

И, наконец, если "чистая" стрелка представляет собой всего лишь функцию, то мы можем закрутить наш цикл и извлечь стрелку a:

> unMix :: Arrow a => Mix a (->) :~> a
> unMix (Mix a b) = a $ arr b

Да, именно так. Нам не требуется здесь замыкать цикл — в определении функции liftA это уже сделано. Все нужные циклы уже есть, ожидают, пока мы ими воспользуемся — вот мы ими и пользуемся.
Несколько примеров. Я введу специальную стрелку для тестов и уберу в класс те функции, которые нам потребуются:

> newtype Test input output = Test {runTest :: Mix (Kleisli IO) (Kleisli (State String)) input output}
>     deriving (Category, Arrow, ArrowLoop)
> class ArrowLoop a => ArrowTest a where
>     rd :: a () String -- ввести строку с клавиатуры
>     wr :: a String () -- вывести строку на экран
>     gt :: a () String -- прочитать текущее состояние
>     pt :: a String () -- изменить текущее состояние
> instance ArrowTest Test where
>     rd = Test {runTest = liftA $ Kleisli $ const $ putStr "::: " >> getLine}
>     wr = Test {runTest = liftA $ Kleisli putStrLn}
>     gt = Test {runTest = liftB $ Kleisli $ const get}
>     pt = Test {runTest = liftB $ Kleisli put}

Для облегчения программирования я введу такой морфизм стрелок:

> stMorphism :: s -> Kleisli (State s) :~> (->)
> stMorphism s al i_input = evalState (runKleisli al i_input) s

И нам потребуется функция, которая запускает тест:

> doTest :: Test input output -> input -> IO output
> doTest t = runKleisli (arrCancelUnit $ unMix $ alongMap (stMorphism "") $ runTest $ first t)

Здесь надо учесть, что большой морфизм unMix . alongMap (stMorphism "") . runTest, увы, работает с типом Along — то есть, требует, чтобы входы и выходы были парами (чего угодно), и чтобы аргумент его был также стрелкой, обрабатывающей пары. Ну, добавить вторым компонентом тип () нам нетрудно — что мы и делаем при помощи функций arrCancelUnit и first.
Собственно тесты. Их будет три:

> test1, test2, test3 :: ArrowTest a => a () ()

Первый тест — почти простое эхо: мы вводим строку с клавиатуры, сохраняем её в состояние, вытаскиваем из состояния и выводим на экран:

> test1 =
>     proc () ->
>         do line <- rd -< ()
>            pt -< line
>            line' <- gt -< ()
>            wr -< line'

Запускаем:

*Mix> doTest test1 ()
::: aaa
aaa

Однако, работает.
Что интересно, "чистые" стрелки вполне можно переставлять с настоящими эффектами. Например:

> test2 =
>     proc () ->
>         do rec {pt -< line;
>                 line <- rd -< ();}
>            rec {line' <- gt -< ();
>                 wr -< line';}
>            returnA -< ()

Запускаем:

*Mix> doTest test2 ()
::: bbb
bbb

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

> test3 =
>     proc () ->
>         do line <- rd -< ()
>            rec {line' <- gt -< ();
>                 pt -< line;}
>            wr -< line'

Запуск показывает, что вместо эха мы выводим пустую строку — что ожидаемо, так как мы забираем текущее состояние ДО того, как записываем новое:

*Mix> doTest test3 ()
::: ccc

Однако, во всём этом зияет один провал. У нас нет ветвлений. Нет ArrowChoice. И с данным типом мы его не получим — ну, по крайней мере, у меня не получилось. Однако, сделать это всё-таки можно. Один из вариантов — вместо Along a i o :~> a использовать тип Along i (Either o i) :~> a Тогда всё получится. Действительно, нам необходимо, если на вход поступило что-то посторонее, что нужно пропустить неизменным, откуда-то взять этот самый тип o. Обычно мы получали его из входных данных, при помощи стрелки b, но если на входе мусор, то это не получится. Поэтому, мы просто используем тот же самый тип i.
Однако, при этом усложнится построение композиции — нужно будет постоянно разбирать эти Either, а потом собирать их обратно. Я предпочитаю другой вариант — добавить функцию типа i -> o. В простых случаях это будет то самое Right :: i -> Either o i, а в более сложных мы получим некоторую свободу. Всё это выливается в такой вот код:

> data MixC a b input output where MixC :: (i -> o) -> (Along a i o :~> a) -> Along b i o input output -> MixC a b input output
> liftCA :: (ArrowChoice a, ArrowLoop a, Arrow b) => a input output -> MixC a b input output
> liftCA a = MixC Right (\al -> loop $ al >>> second (a ||| id)) (arr $ swap . first Left)
> liftCB :: (Arrow a, Arrow b) => b input output -> MixC a b input output
> liftCB b = MixC id arrCancelUnit (first b)
> instance (Arrow a, Arrow b) => Category (MixC a b) where
>     id = liftCB id
>     MixC r2 a2 b2 . MixC r1 a1 b1 = MixC (r2 *** r1) (a2 . a1 . arrAssocRtoL) (arrAssocLtoR $ twist ^>> first b1 >>> twist ^>> first b2)
> instance (Arrow a, Arrow b) => Arrow (MixC a b) where
>     arr = liftCB . arr
>     first (MixC r a b) = MixC r a (arrTwist $ first b)
> instance (Arrow a, ArrowLoop b) => ArrowLoop (MixC a b) where loop (MixC r a b) = MixC r a (loop $ arrTwist b)
> instance AlongMap (MixC a) where alongMap h (MixC r a b) = MixC r a (arrTwist $ h $ arrTwist b)
> unMixC :: Arrow a => MixC a (->) :~> a
> unMixC (MixC _ a b) = a $ arr b

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

> instance (Arrow a, ArrowChoice b) => ArrowChoice (MixC a b) where
>     left (MixC r a b) = MixC r a (f ^>> left b >>^ g) where
>         f (Left input, i) = Left (input, i)
>         f (Right z, i) = Right (z, i)
>         g (Left ~(output, o)) = (Left output, o)
>         g (Right ~(z, i)) = (Right z, r i)

И всё.
Соответственно, чтобы всё это протестировать, нам понадобится новая тестовая стрелка:

> newtype TestC input output = TestC {runTestC :: MixC (Kleisli IO) (Kleisli (State String)) input output}
>     deriving (Category, Arrow, ArrowChoice, ArrowLoop)
> instance ArrowTest TestC where
>     rd = TestC {runTestC = liftCA $ Kleisli $ const $ putStr "::: " >> getLine}
>     wr = TestC {runTestC = liftCA $ Kleisli putStrLn}
>     gt = TestC {runTestC = liftCB $ Kleisli $ const get}
>     pt = TestC {runTestC = liftCB $ Kleisli put}
> doTestC :: TestC input output -> input -> IO output
> doTestC t = runKleisli (arrCancelUnit $ unMixC $ alongMap (stMorphism "") $ runTestC $ first t)

Что-нибудь изменилось? По-моему, ничего. Желающие могут запустить первые три теста, и всё будет работать идентично первому варианту.
Проверим ветвление:

> test4 :: TestC () ()
> test4 =
>     proc () ->
>         do pt -< "Welcome"
>            passwd <- rd -< ()
>            if (passwd == "Secret Password")
>               then do line <- gt -< ()
>                       wr -< line
>               else wr -< "Go away"

Запускаем:

*Mix> doTestC test4 ()
::: ddd
Go away
*Mix> doTestC test4 ()
::: Secret Password
Welcome

Ага.
Вот, как-то так.