migmit | Подмешиваем эффекты

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

> {-# 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

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

Иномировой агент

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

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

no subject

no subject