Игрушечный веб - 3

Я таки сделал этот чёртов ArrowLoop!

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

Для начала - шапка:

> {-# LANGUAGE Arrows #-}
> module Loop where
> import Control.Arrow
> import qualified Control.Category as C
> import Control.Monad
> import Control.Monad.Fix
> import Data.Maybe
> import Data.Monoid
> import Pointed
> import Serialize
> import NetState

Здесь нет ничего особо интересного. Единственное что - я импортирую Control.Monad.Fix, потому что в одном месте мне будет удобно явно написать функцию fix.

Тип Signal из предыдущего постинга претерпел некоторые изменения - в частности, он перестал быть монадой и стал функтором:

> newtype Signal link html a = Signal ((a -> link) -> html)
> instance Functor (Signal link html) where fmap f (Signal s) = Signal $ \linkMaker -> s $ linkMaker . f

Кроме того, он является АДДИТИВНЫМ функтором - и я слегка офигел, обнаружив, что в стандартной библиотеке такого класса нет:

> class Functor f => Additive f where
>     azero :: f a
>     aplus :: f a -> f a -> f a
> instance Monoid html => Additive (Signal link html) where
>     azero = Signal $ const mempty
>     Signal s1 `aplus` Signal s2 = Signal $ \linkMaker -> s1 linkMaker `mappend` s2 linkMaker

Старый тип Signal восстанавливается из нового, а его instance Monad - из instance Additive нового:

> data SignalMonad f a = SignalMonad a (f a)
> instance Additive f => Monad (SignalMonad f) where
>     return x = SignalMonad x azero
>     SignalMonad x fx >>= h = let SignalMonad y fy = h x in SignalMonad y $ fmap (\x -> let SignalMonad y _ = h x in y) fx `aplus` fy

Теперь старый тип Signal становится SignalMonad (Signal). Получился симпатичный рефакторинг.

Однако, нам не нужен старый тип Signal. Нам нужен его вариант, имеющий не только выход, но и вход, причём (!) часть его входа может зависеть от выхода. Именно наличие такой зависимости делает возможным создание instance ArrowLoop.

Делаем:

> data SignalArrow f input output = SignalArrow {pure :: input -> output, effect :: (output -> input) -> f output}

От Kleisli(SignalMonad Signal) это отличается только тем, что вместо input в одном месте стоит (output -> input). Вот она и зависимость.

Далее - довольно стандартные инстансы. Основная идея композиции таких стрелок - если мы знаем, как возвращать сигнал из конца в начало, а нам нужно вернуть его из СЕРЕДИНЫ в начало, то мы сначала протаскиваем его в конец, а потом возвращаем в начало известным способом. Аналогично, если нужно вернуть сигнал из конца в середину - мы возвращаем его в начало, а затем протаскиваем в середину.

> instance Additive f => C.Category (SignalArrow f) where
>     id = arr id
>     sl2 . sl1 = SignalArrow {pure = pure sl2 . pure sl1, effect = e}
>         where e reaction = fmap (pure sl2) (effect sl1 $ reaction . pure sl2) `aplus` effect sl2 (pure sl1 . reaction)

Функция first требует некоторого допинывания ногами, но, как только нам удаётся удовлетворить тайпчекер - всё работает.

> instance Additive f => Arrow (SignalArrow f) where
>     arr f = SignalArrow {pure = f, effect = const azero}
>     first sl = SignalArrow {pure = first (pure sl), effect = e}
>         where e reaction = 
>                   let findZ output = let (input, z) = reaction (output, z) in (output, z)
>                   in fmap findZ $ effect sl $ fst . reaction . findZ

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

> instance Additive f => ArrowLoop (SignalArrow f) where
>     loop sl = SignalArrow {pure = \input -> let (output, z) = pure sl (input, z) in output, effect = e}
>         where e reaction = fmap fst $ effect sl $ first reaction

Наконец, самое забавное. ArrowChoice.

Фишка в том, что ArrowChoice даёт нам возможность, в зависимости от приходящих сигналов, рендерить разные части виджета. При этом мы не хотим, чтобы сигнал, пройдя через виджет и вернувшись назад по какому-то циклу, поменял выбор той части, которая должна рендериться. Смена отображаемого куска должна происходить только между загрузками страницы, но не во время. Гарантировать это статически мы не можем никак. Поэтому я сознательно допускаю возможность, что в этом месте вычисление упадёт с ошибкой. Оно не должно падать - и не будет, если страница написана нормально.

> instance Additive f => ArrowChoice (SignalArrow f) where
>     left sl = SignalArrow {pure = left $ pure sl, effect = e}
>         where e reaction =
>                   case fix $ reaction . left (pure sl) of
>                     Left _ -> fmap Left $ effect sl $ \output -> let Left input = reaction $ Left output in input
>                     Right _ -> azero

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

> type Link = String
> type Html = String
> type Widget = NetState (SignalArrow (Signal Link Html))

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

> renderPage :: Widget () output -> Maybe Link -> Html
> renderPage (NetState sl) ml =
>     let Signal render = effect sl $ const ((), maybe point readSer ml)
>     in render $ \(_, local) -> writeSer local

Теперь нужны label, link и state - почти такие же, как в прошлом постинге.

Для начала - label. Выход label - всегда (), поэтому обратная связь не может быть ничем, кроме константы; нас интересует, следовательно, её единственное значение:

> label :: Widget String ()
> label = NetState $ SignalArrow {pure = const ((),()), effect = \reaction -> Signal $ const $ fst (reaction ((),())) ++ "\n"}

Вход link - всегда (), поэтому обратная связь может быть только const (). Поэтому, мы её вообще проигнорируем.

> link :: String -> Widget () Bool
> link caption = NetState $ SignalArrow {pure = const (False, ()), effect = const $ Signal $ \linkMaker -> caption ++ " <" ++ linkMaker (True, ()) ++ ">\n"}

Ну и, наконец, state. State не отображается никак, а потому не интересуется обратной связью.

> state :: Serialize local => local -> Widget (local -> local) local
> state initial = NetState $ SignalArrow {pure = p, effect = const azero}
>     where p (f, ml) = let l = fromMaybe initial ml in (l, Just $ f l)

Готово. Попробуем, чтобы убедиться, что старые примеры продолжают работать:

> test1 =
>     proc () ->
>         do clicked <- link "+" -< ()
>            number <- state (0 :: Integer) -< if clicked then (+ 1) else id
>            label -< show number
>            link "refresh" -< ()

Загружаем в GHCi:

*Loop> putStr $ renderPage test1 $ Nothing
+ <Y1,>
0
refresh <Y0,>
*Loop> putStr $ renderPage test1 $ Just "Y1,"
+ <Y2,>
1
refresh <Y1,>

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

> test5 =
>     proc () ->
>         do rec {label -< show number;
>                 number <- state (0 :: Integer) -< if clicked then (+ 1) else id;
>                 clicked <- link "+1" -< ()}
>            link "refresh" -< ()

В этом примере всё почти также, как и в test1 - только ссылка, изменяющая счётчик, расположена ПОСЛЕ самого счётчика. Это было невозможно со старой реализацией, зато с новой:

*Loop> putStr $ renderPage test5 $ Nothing
0
+1 <Y1,>
refresh <Y0,>
*Loop> putStr $ renderPage test5 $ Just "Y1,"
1
+1 <Y2,>
refresh <Y1,>

Работает, однако. Чувствую, пора из игрушечного фреймворка делать полноразмерный.

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